home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / toplevel.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-22  |  9.4 KB  |  348 lines
  1. /*
  2.  *
  3.  * t o p l e v e l . c                -- The REP loop
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.    
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *         Author: Erick Gallesio [eg@kaolin.unice.fr]
  21.  *    Creation date:  6-Apr-1994 14:46
  22.  * Last file update: 22-Jul-1996 21:11
  23.  */
  24.  
  25. #include "stk.h"
  26. #include "gc.h"
  27.  
  28. /* The cell representing NIL */
  29. static struct obj VNIL       = {0, tc_nil};
  30.  
  31.  
  32. static void print_banner(void)
  33. {
  34.   if (VCELL(Intern(PRINT_BANNER)) != Ntruth){
  35.     fprintf(STk_stderr, "Welcome to the STk interpreter version %s [%s]\n", 
  36.         STK_VERSION, MACHINE);
  37.     fprintf(STk_stderr, "Copyright ⌐ 1993-1996 Erick Gallesio - ");
  38.     fprintf(STk_stderr, "I3S - CNRS / ESSI <eg@unice.fr>\n");
  39.   }
  40. }
  41.  
  42. static void weird_dirs(char *argv0)
  43. {
  44.   STk_panic("Could not find the directory where STk was installed.\nPerhaps some directories don't exist, or current executable (\"%s\") is in a strange place.\nYou should consider to set the \"STK_LIBRARY\" shell variable.\nExecution is aborted.", argv0);
  45. }
  46.  
  47. static void load_init_file(void)
  48. {
  49.   /* Try to load init.stk in "." and, if not present, in $STK_LIBRARY/STk */
  50.   char init_file[] = "init.stk";
  51.   char file[2*MAX_PATH_LENGTH];
  52.  
  53.   sprintf(file, "./%s", init_file);
  54.   if (STk_loadfile(file, 0) == Truth) return;
  55.  
  56.   sprintf(file, "%s/STk/%s", STk_library_path, init_file);
  57.   if (STk_loadfile(file, 0) == Ntruth)
  58.     weird_dirs(STk_Argv0);
  59. }
  60.  
  61. static void init_library_path(char *argv0)
  62. {
  63.   char *s;
  64.  
  65.   STk_library_path = "";
  66.  
  67.   if (s = getenv("STK_LIBRARY")) {
  68.     /* Initialize STk_library_path with the content of STK_LIBRARY 
  69.      * shell variable.
  70.      * Make a copy of environment variable (copy is necessary for
  71.      * images files) 
  72.      */
  73.     STk_library_path = (char *) must_malloc(strlen(s) + 1); 
  74.     strcpy(STk_library_path, s);
  75.   }
  76.   else {
  77.     SCM canonical_argv0 = STk_resolve_link(argv0, 0);
  78.     
  79.     if (canonical_argv0 != Ntruth) {
  80.       /* STk_library must be set to the parent directory of the executable */
  81.       char *s, *e;
  82.  
  83.       s = CHARS(canonical_argv0);
  84.       e = s + strlen(s) - 1;
  85.       
  86.       while (e > s && !ISDIRSEP(*e)) e -= 1;    /* delete exec    name */
  87.       e -= 1;
  88.       while (e > s && !ISDIRSEP(*e)) e -= 1;    /* delete directory name */
  89.       *e = '\0';
  90.       
  91.       STk_library_path = must_malloc(strlen(s) + 1);
  92.       strcpy(STk_library_path, s);
  93.     }
  94.     else weird_dirs(argv0);
  95.   }
  96. }
  97.  
  98. static void init_interpreter(void)
  99. {
  100. #ifdef WIN32
  101.   /* First initialize the IO system, to have a console on Windows */
  102.   STk_init_io();
  103. #endif
  104.  
  105.   /* Remember if we are running the stk or snow interpreter */
  106. #ifdef USE_TK
  107.   STk_snow_is_running = FALSE;
  108. #else
  109.   STk_snow_is_running = TRUE;
  110. #endif
  111.  
  112.   /* Global variables to initialize */
  113.   NIL           = &VNIL;
  114.   STk_tkbuffer       = (char *) must_malloc(TKBUFFERN+1);
  115.   STk_interactivep = STk_arg_interactive ||isatty(fileno(STk_stdin));
  116.  
  117.   /* Initialize GC */
  118.   STk_init_gc();
  119.  
  120.   /* Initialize symbol & keyword tables */
  121.   STk_initialize_symbol_table();
  122.   STk_initialize_keyword_table();
  123.  
  124.   /* 
  125.     * Define some scheme objects used by the interpreter 
  126.     * and protect them against GC 
  127.     */
  128.   NEWCELL(UNDEFINED, tc_undefined); STk_gc_protect(&UNDEFINED);
  129.   NEWCELL(UNBOUND,   tc_unbound);   STk_gc_protect(&UNBOUND);
  130.   NEWCELL(Truth,     tc_boolean);   STk_gc_protect(&Truth);
  131.   NEWCELL(Ntruth,    tc_boolean);   STk_gc_protect(&Ntruth);
  132.  
  133.   Sym_lambda       = Intern("lambda");         STk_gc_protect(&Sym_lambda);
  134.   Sym_quote       = Intern("quote");         STk_gc_protect(&Sym_quote);
  135.   Sym_imply       = Intern("=>");         STk_gc_protect(&Sym_imply);
  136.   Sym_dot       = Intern(".");         STk_gc_protect(&Sym_dot);
  137.   Sym_debug       = Intern(DEBUG_MODE);     STk_gc_protect(&Sym_debug);
  138.   Sym_else       = Intern("else");         STk_gc_protect(&Sym_else);
  139.   Sym_quasiquote   = Intern("quasiquote");     STk_gc_protect(&Sym_quasiquote);
  140.   Sym_unquote       = Intern("unquote");         STk_gc_protect(&Sym_unquote);
  141.   Sym_unq_splicing = Intern("unquote-splicing"); STk_gc_protect(&Sym_unq_splicing);
  142.   Sym_break       = Intern("break");         STk_gc_protect(&Sym_break);
  143.  
  144.   STk_globenv       = STk_makeenv(NIL, 1);     STk_gc_protect(&STk_globenv);
  145.  
  146.   /* GC_VERBOSE and REPORT_ERROR must ABSOLUTLY initialized before any GC occurs
  147.     * Otherwise, they will be allocated during a GC and this lead to an infinite 
  148.     * loop
  149.     */
  150.   VCELL(Intern(GC_VERBOSE))    = Ntruth;
  151.   VCELL(Intern(REPORT_ERROR))    = NIL;
  152.  
  153.   VCELL(Intern(LOAD_SUFFIXES))    = NIL;
  154.   VCELL(Intern(LOAD_PATH))    = NIL;
  155.   VCELL(Intern(LOAD_VERBOSE))    = Ntruth;
  156.  
  157.   /* Initialize the path of the library */
  158.   init_library_path(STk_Argv0);
  159.  
  160.   /* Initialize *eval-hook* */
  161.   STk_init_eval_hook();
  162.  
  163.   /* Initialize standard ports */
  164.   STk_init_standard_ports();
  165.  
  166.   /* Initialize Scheme primitives */
  167.   STk_init_primitives();
  168.  
  169.   /* Initialize signal table */
  170.   STk_init_signal();
  171.  
  172.   /* initialize STk_wind_stack and protect it against garbage colection */
  173.   STk_wind_stack = NIL;     STk_gc_protect(&STk_wind_stack);
  174. }
  175.  
  176. static void finish_initialisation(void)
  177. {
  178.   /* 
  179.    * Initialize user extensions 
  180.    */
  181.   STk_user_init();
  182.  
  183.   /* 
  184.    * Manage -file if it exists. Behaviour is different if TK is used and inited
  185.    */
  186.   if (STk_arg_file) {
  187.     STk_loadfile(STk_arg_file, TRUE);
  188.     /* Reset default action on SIGINT */
  189.     signal(SIGINT, SIG_DFL);
  190.     STk_interactivep = 0;
  191. #ifdef USE_TK
  192.     if (Tk_initialized) Tk_MainLoop();
  193. #endif
  194.     exit(0);
  195.   }
  196. #if (defined(USE_TK) && !defined(WIN32))
  197.   else {
  198.     /*
  199.      * Commands come from standard input. Set up a handler to receive 
  200.      * stdin characters.
  201.      */
  202.     Tcl_File f = Tcl_GetFile((ClientData) fileno(STk_stdin),  TCL_UNIX_FD);
  203.   
  204.     Tcl_CreateFileHandler(f,
  205.               TCL_READABLE,
  206.               (Tk_FileProc *) STk_StdinProc, 
  207.               (ClientData) NULL);
  208.   }
  209. #endif
  210.   
  211.   /* 
  212.    * See if we've used the -interactive option; if so, 
  213.    *        - unbufferize stdout and  stderr so that the interpreter can
  214.    *          be used with Emacs and 
  215.    *        - print the STk banner
  216.    */
  217.   if (STk_interactivep) {
  218.     static char *out, *err;
  219.  
  220.     out = STk_line_bufferize_io(STk_stdout);
  221.     err = STk_line_bufferize_io(STk_stderr);
  222.     print_banner();
  223.   }
  224.   fflush(stdout);
  225.   /* 
  226.    * Manage -load option 
  227.    */
  228.   if (STk_arg_load) {
  229.     STk_loadfile(STk_arg_load, TRUE);
  230. #ifdef USE_TK
  231.     if (Tk_initialized) Tcl_GlobalEval(STk_main_interp, "(update)");
  232. #endif
  233.   }
  234. }
  235.  
  236. static void repl_loop(void)
  237. {
  238.   /* The print/eval/read loop */
  239.   for( ; ; ) {
  240.     SCM x;
  241.  
  242.     if (STk_interactivep) {
  243.       fprintf(STk_stderr, "STk> ");
  244.       fflush(STk_stderr); 
  245.       fflush(STk_stdout);    /* This is for Ilisp users */
  246.     }
  247.     if (EQ(x=STk_readf(STk_stdin, FALSE), STk_eof_object)) return;
  248.     x = STk_eval(x, NIL);
  249.     if (STk_dumped_core) {
  250.       /* 
  251.        * When restoring an image we arrive here x contains the result of applying
  252.        * the saved continuation.
  253.        */
  254.       STk_dumped_core = 0;
  255.       longjmp(*Top_jmp_buf, JMP_RESTORE);
  256.     }
  257.     else {
  258.       STk_print(x, STk_curr_oport, WRT_MODE);
  259.       Putc('\n', STk_stdout);
  260.     }
  261.   }
  262. }
  263.  
  264. static void repl_driver(int argc, char **argv)
  265. {
  266.   static int k;
  267.   static char **new_argv;
  268.   
  269.   new_argv = STk_process_argc_argv(argc, argv);
  270.  
  271.   if (STk_arg_image) {
  272.     STk_save_unix_args_and_environment(argc, argv);
  273.     STk_restore_image(STk_arg_image);
  274.   }
  275.   else {
  276.     /* Normal initialisation */
  277.     STk_reset_eval_stack();
  278.   }
  279.  
  280.   /* Point where we come back on errors, image restoration, ... */
  281.   k = setjmp(*Top_jmp_buf);
  282.   
  283.   Error_context         = ERR_OK;    
  284.   STk_sigint_counter = 0;
  285.   STk_control_C         = 0;
  286.  
  287.   switch (k) {
  288.     case 0:        init_interpreter();
  289.             STk_initialize_scheme_args(new_argv);
  290.             load_init_file();
  291. #ifdef USE_TK
  292. #  ifdef WIN32
  293.             if (!STk_arg_no_tk)
  294.               Tk_main(STk_arg_sync,
  295.                   STk_arg_name,
  296.                   STk_arg_file,
  297.                   "localhost:0",
  298.                   STk_arg_geometry);
  299. #  else
  300.             if (!STk_arg_Xdisplay) 
  301.               STk_arg_Xdisplay =  getenv("DISPLAY");
  302.             if (!STk_arg_no_tk && STk_arg_Xdisplay)
  303.               Tk_main(STk_arg_sync,
  304.                   STk_arg_name,
  305.                   STk_arg_file,
  306.                   STk_arg_Xdisplay,
  307.                   STk_arg_geometry);
  308. #  endif
  309. #endif
  310.             finish_initialisation();
  311.             break;
  312.     case JMP_RESTORE:    STk_restore_unix_args_and_environment(&argc, &argv);
  313.             /* Process another time args since we have lost them ! */
  314.             new_argv = STk_process_argc_argv(argc, argv);
  315.             STk_initialize_scheme_args(new_argv);
  316. #ifdef USE_TK
  317.             if (!STk_arg_no_tk && (STk_arg_Xdisplay||getenv("DISPLAY")))
  318.               Tk_main(STk_arg_sync, 
  319.                   STk_arg_name, 
  320.                   STk_arg_file, 
  321.                   STk_arg_Xdisplay,
  322.                   STk_arg_geometry);
  323. #endif
  324.             finish_initialisation();
  325.             break;
  326.     case JMP_THROW:
  327.     case JMP_ERROR:    break;
  328.   }
  329.  
  330.   repl_loop();
  331.   if (STk_interactivep) fprintf(STk_stderr, "Bye.\n");
  332.   STk_quit_interpreter(UNBOUND);
  333. }
  334.  
  335. /******************************************************************************
  336.  *
  337.  * Toplevel
  338.  * 
  339.  ******************************************************************************/
  340.  
  341. void STk_toplevel(int argc, char **argv)
  342. {
  343.   SCM stack_start; /* Unused variable. Its the first stack allocated variable */
  344.  
  345.   STk_stack_start_ptr = &stack_start;
  346.   repl_driver(argc, argv);
  347. }
  348.